home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / ai / neural22 / slug3.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-15  |  41KB  |  1,315 lines
  1. {$F+}
  2.  
  3. uses objects,owindows,odialogs,strings,win31,windos, wintypes,winprocs,
  4.      ostddlgs,bwcc,bpnet2, nnunit2, dyna3,wintools,cfmtools
  5. {$IFDEF DEBUG}
  6. ,WINCRT
  7. {$ENDIF}
  8. ;
  9.  
  10. {$I c:\neural\slug3\SLUG3.inc}
  11. {$R c:\neural\slug3\slug3}
  12. const
  13.   wm_openthisfile  = wm_user + 1;  {message to editor to open file}
  14.  
  15. type
  16.  
  17.    nninitdata = record
  18.            inputsize            : longint;
  19.            outputsize           : longint;
  20.            hiddensize           : longint;
  21.    end;
  22.  
  23.    NNLearnparams  = record
  24.            Lcoeff         : double;
  25.            momentum       : double;
  26.            Kmod           : double;
  27.            Maxerr         : double;
  28.            Maxiter        : longint;
  29.    end;
  30.  
  31.    TrainStepRec = record
  32.            DMdesired     : pdynamat;
  33.            DMinput       : pdynamat;
  34.            DVerror       : pdynavec;
  35.    end;
  36.  
  37.    Transferfuncrec = record
  38.            hiddentanh,hiddensigmoid,hiddenlinear,
  39.            outputtanh,outputsigmoid,outputlinear   : WORD;
  40.    end;
  41.  
  42.  
  43.    pannpgm  = ^ANNpgm;
  44. {----------------------------}
  45.    ANNpgm   = object(tapplication)
  46. {----------------------------}
  47.  
  48.       procedure Initmainwindow; virtual;
  49.  
  50.    end;
  51.  
  52.  
  53.     pNNwindow   = ^NNwindow;
  54. {----------------------------}
  55.     NNWindow    = object(tdlgwindow)
  56. {----------------------------}
  57.       net                   : psimplebpnet;
  58.       inname                : array[0..fspathname] of char;
  59.       outname               : array[0..fspathname] of char; {these contain a network on stream}
  60.       datainname            : array[0..fspathname] of char;
  61.       logname,
  62.       lastlog               : array[0..fspathname] of char; {these contain network data}
  63.       infile,
  64.       outfile               : pdosstream; {streams for network}
  65.       datainfile,
  66.       logfile               : text;
  67.       initbuffer            : nninitdata; {user data}
  68.       learnbuffer           : NNlearnparams;
  69.       funcbuffer            : transferfuncrec;
  70.       datainopen            : boolean;  {are the data files open? }
  71.       logopen               : boolean;
  72.       netok,dataok,logok    : boolean;  {are these specified ?}
  73.       modified              : boolean;  {refers to network spec file}
  74.       running               : boolean;
  75.       training              : boolean;
  76.       stopped               : boolean;
  77.       logappend             : boolean; {Logfile Append check box}
  78.       randomdata        : boolean;  {Present data randomly}
  79.       edmomentum,edlearn,                 {edit controls in the main dialog box}
  80.       edkmod,edmaxerr,
  81.       infolearn,
  82.       infomomentum          : PSTATIC; {pfloatedit;  don't need these in BP7...}
  83.       edmaxiter             : Pstatic; {pnumedit;}
  84.       edinfocount           : pnumedit;
  85.       edinfoerror           : pfloatedit;
  86.       eddatafile,
  87.       edlogfile             : Pstatic; {pedit;}
  88.       chlogappend,
  89.       chrandomdata          : pcheckbox;
  90.  
  91.  
  92.       constructor init(aparent : pwindowsobject; atitle  : pchar);
  93.       destructor done; virtual;
  94.       function  canclose : boolean; virtual;
  95.       function  getclassname : pchar ;virtual;
  96.       procedure getwindowclass(var awndclass : twndclass); virtual;
  97.       procedure CMnewfile(var mess : tmessage); virtual cm_first +cm_filenew;
  98.       procedure CMopenfile(var mess : tmessage); virtual cm_first +cm_fileopen;
  99.       procedure CMsavefile(var mess : tmessage); virtual cm_first +cm_filesave;
  100.       procedure CMsaveasfile(var mess : tmessage); virtual cm_first +cm_filesaveas;
  101.       procedure CMEXit(var mess : tmessage); virtual cm_first +cm_exit;
  102.       procedure CMbuildnet(var mess : tmessage); virtual ;
  103.       procedure CMdatain(var mess : tmessage); virtual cm_first +cm_datain;
  104.       procedure CMdataout(var mess : tmessage); virtual cm_first +cm_dataout;
  105.       procedure CMSetTransfer(var mess : tmessage); virtual cm_first+cm_settransfer;
  106.       procedure SetTransferFunctions;
  107.       procedure CMtrain(var mess : tmessage); virtual cm_first +cm_train;
  108.       procedure CMtrainparams(var mess: tmessage); virtual cm_first+ cm_trainedit;
  109.       procedure CMrun(var mess : tmessage); virtual cm_first +cm_run;
  110.       procedure CMAbout(var mess : tmessage); virtual cm_first +cm_about;
  111.       procedure CMSlughelp(var mess : tmessage); virtual cm_first + cm_slughelp;
  112.       procedure CMdisplay(var mess : tmessage); virtual cm_first +cm_display;
  113.       procedure BNResetweights(var mess : tmessage); virtual id_first+ id_reset;
  114.       procedure BNstopnet(var mess : tmessage); virtual id_first+ id_iterstop;
  115.       procedure BNsavenet(var mess : tmessage); virtual id_first+ id_savenet;
  116.       procedure BNreadnet(var mess : tmessage); virtual id_first+ id_readnet;
  117.       procedure BNshakenet(var mess : tmessage); virtual id_first+ id_shake;
  118.       procedure BNtrain(var mess : tmessage); virtual id_first+ id_train;
  119.       procedure BNSettransfer(var mess : tmessage); virtual id_first+ id_settransfer;
  120.       procedure BNdataopen(var mess : tmessage);virtual id_first+id_dataopen;
  121.       procedure BNdataclose(var mess : tmessage); virtual id_first+id_dataclose;
  122.       procedure BNlogopen(var mess : tmessage); virtual id_first+id_logopen;
  123.       procedure BNlogclose(var mess : tmessage); virtual id_first+id_logclose;
  124.       procedure BNtrainparams(var mess : tmessage); virtual id_first+id_trainparams;
  125.       procedure BNdataedit(var mess : tmessage); virtual id_first+id_dataedit;
  126.       procedure BNLogedit(var mess : tmessage); virtual id_first+id_logedit;
  127.       procedure CHrandom(var mess : tmessage); virtual id_first+id_random;
  128.       procedure EditFile(pathname : pchar);
  129.       procedure trainsession;
  130.       function  trainepoch(var data : trainsteprec; count: word) : double;
  131.       procedure setupnetparams;
  132.       procedure showtrainparams;
  133.       procedure shownetparams;
  134.       procedure showicon(state : word);
  135.       function  closelogfile    : boolean;
  136.       function  closedatafile   : boolean;
  137.       function  killnet         : boolean;
  138.       procedure report(rep :pchar);          
  139.  
  140.     end;
  141.  
  142.  
  143.     pSpecdialog = ^Specdialog;
  144. {----------------------------}
  145.     Specdialog  = object(tdialog)
  146. {----------------------------}
  147.        procedure zerocounts(var mess : tmessage); virtual
  148.                                                  id_first + id_netspecclear;
  149.     end;
  150.  
  151. var tempstr  : string;
  152.  
  153.  
  154.    {--------------------- NNWINDOW PROCEDURES --------------------------}
  155.  
  156.  
  157.  
  158. {----------------------------}
  159. constructor nnwindow.init(aparent : pwindowsobject;
  160.                           atitle  : pchar);
  161. {----------------------------}
  162. begin
  163.      tdlgwindow.init(aparent,atitle);
  164.      ismodal  := false;
  165.      if neuralerror <> 0 then
  166.        begin
  167.        printneuralerror;
  168.        exit;
  169.        end;
  170.      strpcopy(outname,'');
  171.      strpcopy(inname,'*.ann');
  172.      strpcopy(datainname,'');
  173.      strpcopy(logname,'');
  174.      strpcopy(lastlog,'');
  175.      infile         := nil;
  176.      outfile        := nil;
  177.      net            := nil;
  178.      modified   := false;
  179.  
  180.      running    := false;
  181.      stopped    := false;
  182.      training   := false;
  183.      datainopen := false;
  184.      logopen    := false;
  185.      logok      := false;
  186.      dataok     := false;
  187.      netok      := false;
  188.      logappend  := false;
  189.  
  190.  
  191.      with initbuffer do
  192.         begin
  193.         inputsize     := 2;
  194.         outputsize    := 1;
  195.         hiddensize    := 2;
  196.         end;
  197.      with learnbuffer do
  198.         begin
  199.         lcoeff      := 0.5;
  200.         momentum    := 0.8;
  201.         kmod        := 0;
  202.         maxerr      := 0.1;
  203.         maxiter     := 20000;
  204.         end;
  205.                 {set transferfunction specs}
  206.      with funcbuffer do
  207.         begin
  208.         hiddentanh    := BF_unchecked;
  209.         hiddensigmoid := BF_checked;
  210.         hiddenlinear  := BF_unchecked;
  211.         outputtanh    := BF_unchecked;
  212.         outputsigmoid := BF_unchecked;
  213.         outputlinear  := BF_checked;
  214.     end;
  215.                 { Initialize the edit controls }
  216.      new(edmomentum,initresource(@self,ed_usermomen,6));
  217.      new(edlearn,initresource(@self,ed_userlearn,6));
  218.      new(edkmod,initresource(@self,ed_userepoch,6));
  219.      new(edmaxerr,initresource(@self,ed_usermaxerr,6));
  220.      new(edmaxiter,initresource(@self,ed_usermaxiter,6));
  221.      new(eddatafile,initresource(@self,ed_userdatafile,20));
  222.      new(edlogfile,initresource(@self,ed_userlogfile,20));
  223.  
  224.      new(edinfocount,initresource(@self,ed_infocount,6,1,999));
  225.      new(edinfoerror,initresource(@self,ed_infoerror,6,0.0,9999.9));
  226.      new(infolearn,initresource(@self,ed_infolearn,6));
  227.      new(infomomentum,initresource(@self,ed_infomomen,6));
  228.      new(chlogappend,initresource(@self,id_append));
  229.      new(chrandomdata,initresource(@self,id_random));
  230.  
  231.      showicon(sw_hide);
  232.  
  233. end;
  234.  
  235. {----------------------------}
  236. destructor nnwindow.done;
  237. {----------------------------}
  238. begin
  239.      if net <> nil then dispose(net,done);
  240.      dispose(edmomentum, done);
  241.      dispose(edlearn,done);
  242.      dispose(edkmod,done);
  243.      dispose(edmaxerr,done);
  244.      dispose(edmaxiter,done);
  245.      dispose(eddatafile,done);
  246.      dispose(edlogfile,done);
  247.  
  248.      dispose(edinfocount,done);
  249.      dispose(edinfoerror,done);
  250.      dispose(infolearn,done);
  251.      dispose(infomomentum,done);
  252.      dispose(chlogappend,done);
  253.      dispose(chrandomdata,done);
  254.  
  255.      if datainopen then close(datainfile);
  256.      if logopen then close(logfile);
  257.  
  258.      tdlgwindow.done;
  259. end;
  260.  
  261.  
  262. {----------------------------}
  263. function nnwindow.getclassname : pchar;
  264. {----------------------------}
  265. begin
  266.      getclassname := 'neuralnetwindow';
  267. end;
  268.  
  269. {----------------------------}
  270. procedure nnwindow.getwindowclass(var awndclass : twndclass);
  271. {----------------------------}
  272. begin
  273.      tdlgwindow.getwindowclass(awndclass);
  274.      awndclass.hicon := loadicon(hinstance,'networkicon');
  275.      awndclass.lpszmenuname    := 'themenu';
  276.      Awndclass.hbrbackground := getstockobject(null_brush);
  277.         {Remember to specify the menu in the resource file !}
  278. end;
  279.  
  280.  
  281. {----------------------------}
  282. function nnwindow.canclose : boolean;
  283. {----------------------------}
  284. var
  285.    reply : integer;
  286.    mess  : tmessage;
  287. begin
  288.     canclose := true;
  289.     if training or running then
  290.       begin
  291.       BNstopnet(mess);
  292.       canclose := false;
  293.       exit;
  294.       end;
  295.     if netok and modified then
  296.         begin
  297.         reply := messagebox(hwindow,'Lose your changes ?','Net has changed...',
  298.                         mb_yesno or mb_iconquestion);
  299.         if reply = idno then
  300.            canclose := false
  301.         else
  302.             begin
  303.             canclose := true;
  304.             if net <> nil then
  305.                begin
  306.                dispose(net,done);
  307.                net := nil;
  308.                netok := false;
  309.                showicon(sw_hide);
  310.                end;
  311.             end;
  312.         end;
  313.  
  314. end;
  315.  
  316. {----------------------------}
  317. procedure nnwindow.cmExit(var mess: tmessage);
  318. {----------------------------}
  319. begin
  320.      if not (training or running) then tdlgwindow.CmExit(mess)
  321. end;
  322.  
  323. {----------------------------}
  324. function  nnwindow.closelogfile    : boolean;
  325. {----------------------------}
  326. begin
  327.      if logopen then close(logfile);
  328.      logopen := false;
  329.      logok   := false;
  330.      setdlgitemtext(hwindow,ed_userlogfile,'');
  331.      closelogfile := true;
  332.                  {keep copy of old log name}
  333.      strcopy(lastlog,logname);
  334. end;
  335.  
  336. {----------------------------}
  337. function  nnwindow.closedatafile   : boolean;
  338. {----------------------------}
  339. begin
  340.      if datainopen then close(datainfile);
  341.      datainopen := false;
  342.      dataok   := false;
  343.      setdlgitemtext(hwindow,ed_userdatafile,'');
  344.      closedatafile := true;
  345. end;
  346.  
  347. {----------------------------}
  348. function  nnwindow.killnet         : boolean;
  349. {----------------------------}
  350.                               { If a modified net exists, asks
  351.                                  before disposing of it.
  352.                                  Returns true if the net is disposed.}
  353. var
  354.    ans          : word;
  355.    mess         : Tmessage;
  356.    cankill      : boolean;
  357. begin
  358.      cankill := false;
  359.      if (net = nil) then
  360.          begin
  361.          killnet := true;
  362.          netok := false;
  363.          exit;
  364.          end;
  365.  
  366.      if not modified then cankill := true;
  367.      if modified then   
  368.           begin
  369.           ans := messagebox(hwindow,'Do you want to save it ?',
  370.                               'This net has changed',
  371.                               mb_yesnocancel or mb_iconhand);
  372.           case ans of
  373.             id_cancel : cankill := false;
  374.             id_yes    :
  375.                        begin
  376.                        CMsaveasfile(mess);
  377.                        cankill := true;
  378.                        end;
  379.             id_no     : cankill := true;
  380.             end;
  381.           end;
  382.  
  383.      if cankill then
  384.      begin
  385.      dispose(net,done);
  386.      net := nil;
  387.      netok := false;
  388.      showicon(sw_hide);
  389.      end;
  390.  
  391.      killnet := cankill;
  392. end;
  393.  
  394. {----------------------------}
  395. procedure nnwindow.CMnewfile(var mess : tmessage);
  396. {----------------------------}
  397. var
  398.    ans  : integer;
  399. begin
  400. {$ifdef publicdomain}
  401.        enablewindow(getdlgitem(hwindow,id_settransfer),false);
  402.        enablewindow(getdlgitem(hwindow,id_random),false);
  403.        enablemenuitem(getmenu(hwindow),cm_settransfer,mf_bycommand or mf_grayed);
  404. {$endif}
  405.                         {Throw the old network out and build a new one}
  406.      if not (running or training) then
  407.      if killnet then
  408.         begin
  409.         setdlgitemtext(hwindow,ed_netname,'');
  410.         strcopy(outname,'');
  411.         strcopy(inname,'');
  412.         if datainopen then closedatafile;
  413.         CMbuildnet(mess);
  414.         if net <> nil then
  415.            begin
  416.            netok := true;
  417.            showicon(sw_show);
  418.            shownetparams;
  419.             settransferfunctions;
  420.            end
  421.         else
  422.            begin
  423.            netok := false;
  424.            showicon(sw_hide);
  425.            report('No Network');
  426.            if neuralerror <> 0 then printneuralerror;
  427. {           say('It is best to restart SLUG !');}
  428.            end;
  429.         end;
  430. end;
  431.  
  432. {----------------------------}
  433. procedure nnwindow.CMopenfile(var mess : tmessage);
  434. {----------------------------}
  435.                                 {Throw out old net and read a new one}
  436. var
  437.    result,save       : integer;
  438. begin
  439.      if running or training then exit;
  440.                           { else, net is now nil.
  441.                             If If new name chosen, get it from stream. }
  442.      strcopy(inname,'*.ann');
  443.      if application^.execdialog(new(pfiledialog,init(@self,
  444.                                     pchar(sd_bcfileopen), inname))) = id_ok
  445.      then
  446.        begin
  447.        if not killnet then exit;
  448.        strcopy(outname,inname);
  449.        new(infile,init(inname,stopenread));
  450.        if (infile^.status <> stOK) then
  451.              begin
  452.              say('Could not open file ! ');
  453.              if infile <> nil then dispose(infile,done);
  454.              exit;
  455.              end;
  456.        net := psimplebpnet(infile^.get);
  457.        dispose(infile,done);
  458.  
  459.        if (net <> nil) then    { net OK}
  460.          begin
  461.          netok := true;
  462.          showicon(sw_show);
  463.          shownetparams;
  464.          setdlgitemtext(hwindow,ed_netname,inname);
  465.          if datainopen then closedatafile;
  466.          with initbuffer do
  467.             begin
  468.             inputsize    := net^.inputfield^.count;
  469.             outputsize   := net^.outputfield^.count;
  470.             hiddensize   := net^.hiddenfield^.count;
  471.             end;
  472.          with learnbuffer do
  473.             begin
  474.             lcoeff      := net^.learn;
  475.             momentum    := net^.momen;
  476.             end;
  477.          end
  478.        else                    { Net not OK} 
  479.          begin
  480.          say('No network present !');
  481.          report('Error');
  482.          showicon(sw_hide);
  483.          strcopy(inname,'*.ann');
  484.          strcopy(outname,'');
  485.          setdlgitemtext(hwindow,ed_netname,'');
  486.          netok := false;
  487.          end;  
  488.        end;
  489.      
  490.  
  491. end;
  492.  
  493. {----------------------------}
  494. procedure nnwindow.CMsaveasfile(var mess : tmessage);
  495. {----------------------------}
  496.                               { Overwrites without asking !
  497.                               }
  498. begin
  499.      if (strlen(outname) = 0) then
  500.        strcopy(outname,'*.ann')
  501.      else
  502.        strcopy(outname,inname);
  503.  
  504.      if application^.execdialog(new(pfiledialog,init(@self,
  505.                      pchar(sd_bcFileSave), outname))) = id_ok
  506.      then
  507.        begin
  508.        setdlgitemtext(hwindow,ed_netname,outname);
  509.        modified := false;
  510.        new(outfile,init(outname,stcreate));
  511.        if outfile^.status <> stOK then
  512.           begin
  513.           say('Could not create file ! ');
  514.           exit
  515.           end; 
  516.        outfile^.put(net);
  517.        dispose(outfile,done);
  518.        outfile := nil;
  519.        report('Net saved');
  520.        end;
  521. {$ifdef debug}
  522.      messagebox(hwindow,outname,'File saved as :',mb_ok);
  523. {$endif}
  524. end;
  525.  
  526. {----------------------------}
  527. procedure nnwindow.CMsavefile(var mess : tmessage);
  528. {----------------------------}
  529.  
  530.                                 {Simply save}
  531. begin
  532.      if (net <>nil) and (strlen(outname)<> 0)  then
  533.        begin
  534.        new(outfile,init(outname,stcreate));
  535.        if outfile^.status <> stOK then
  536.           begin
  537.           say('Could not open file ! ');
  538.           Report('Error during stream access');
  539.           exit
  540.           end; 
  541.        outfile^.put(net);
  542.        dispose(outfile,done);
  543.        modified := false;
  544.        report('Net written');
  545.        end
  546.      else
  547.        if (net <>nil) then CMsaveasfile(mess);
  548.  
  549. {$ifdef debug}
  550.      messagebox(hwindow,outname,'Written to :',mb_ok);
  551. {$endif}
  552. end;
  553.  
  554. {-----------------------------------}
  555. procedure nnwindow.CMbuildnet(var mess : tmessage);
  556. {-----------------------------------}
  557. var
  558.    edit1, edit2, edit3, edit4    : pnumedit; {numeric edit boxes}
  559.    dlg                           : pspecdialog;
  560.    result,discard,i              : integer;
  561.  
  562. procedure builddialog;
  563. begin
  564.       new(dlg,init(@self,'netspec1'));   {init the dialog }
  565.       dlg^.transferbuffer := @initbuffer;
  566.                                          {and the controls}
  567.       new(edit1,initresource(dlg,id_netspecin,3,1,999));
  568.       new(edit2,initresource(dlg,id_netspecout,3,1,999));
  569.       new(edit3,initresource(dlg,id_netspechidden,3,1,999));
  570.                                               {execute the dialog}
  571.       result := application^.execdialog(dlg);
  572.       if result <= 0 then say('Could not open the dialog');
  573. end;
  574.  
  575. begin
  576.       if killnet then
  577.          begin
  578.          if datainopen then closedatafile;
  579.          builddialog;
  580.          if result=idok then with initbuffer do
  581.              begin
  582.              new(net,init(initbuffer.inputsize,
  583.                           initbuffer.hiddensize,
  584.                           initbuffer.outputsize,0.5,0.5));
  585.              if net <> nil then
  586.             begin
  587.         net^.shake(0.10);
  588.              report('New network created');
  589.              netok := true;
  590.                 cmsettransfer(mess);
  591.                 end;
  592.  
  593.              end;
  594.  
  595.          modified := false;
  596.          end;
  597.  
  598. end;
  599.  
  600. {--------------------------}
  601. procedure nnwindow.CMdatain(var mess : tmessage);
  602. {--------------------------}
  603. begin
  604.  
  605.      if datainopen then closedatafile;
  606.      strcopy(datainname,'*.dat');
  607.      if application^.execdialog(new(pfiledialog,init(@self,
  608.                      pchar(sd_bcfileopen), datainname))) = id_ok
  609.      then
  610.         begin
  611.         setdlgitemtext(hwindow,ed_userdatafile,datainname);
  612.         dataok := true;
  613.         report('Datafile specified');
  614.         end
  615.      else
  616.          begin
  617.          strcopy(datainname,'');
  618.          dataok := false;
  619.          report('Datafile needs to be specified');
  620.          end;
  621. end;
  622.  
  623.  
  624. {--------------------------}
  625. procedure nnwindow.CMdataout(var mess : tmessage);
  626. {--------------------------}
  627. begin
  628.     if logopen
  629.     then
  630.        if messagebox(hwindow,'Do you want to close it ?','Logfile is open !',
  631.                   mb_yesno or mb_iconhand) = id_no
  632.        then exit
  633.        else
  634.             begin
  635.             closelogfile;
  636.             logopen := false;
  637.             logok := false;
  638.             report('Logfile closed');
  639.             end;
  640.  
  641.     strcopy(logname,'*.log');
  642.     if application^.execdialog(new(pfiledialog,init(@self,
  643.                 pchar(sd_bcfileopen), logname))) = id_ok
  644.     then
  645.           begin
  646.           logok := true;
  647.           logopen := false;
  648.           setdlgitemtext(hwindow,ed_userlogfile,logname);
  649.           if chlogappend^.getcheck = bf_checked then logappend := true
  650.              else logappend := false;
  651.           Report('Logfile specified');
  652.           end;
  653.  
  654. end;
  655. {--------------------------}
  656. procedure NNWindow.SetTransferfunctions;
  657. {--------------------------}
  658. var
  659.    thefield  : neuronfield;
  660.    thefunction :  signaltype;
  661. begin
  662.  
  663.      if funcbuffer.hiddentanh    = bf_checked then thefunction := tanh;
  664.      if funcbuffer.hiddensigmoid = bf_checked then thefunction := sigmoid;
  665.      if funcbuffer.hiddenlinear  = bf_checked then thefunction := linear;
  666.      net^.setfieldsignal(net^.hiddenfield,thefunction);
  667.      if funcbuffer.outputtanh    = bf_checked then thefunction := tanh;
  668.      if funcbuffer.outputsigmoid = bf_checked then thefunction := sigmoid;
  669.      if funcbuffer.outputlinear  = bf_checked then thefunction := linear;
  670.      net^.setfieldsignal(net^.outputfield,thefunction);
  671.  
  672. end;
  673. {--------------------------}
  674. procedure NNWindow.CMSetTransfer(var mess : tmessage);
  675. {--------------------------}
  676. var
  677.    dlg         : pdialog;
  678.    dlgok     : integer;
  679.    button    : Pradiobutton;
  680. begin
  681.      if net=nil then exit;
  682. {$ifdef publicdomain}
  683.      net^.setfieldsignal(net^.outputfield,linear);
  684.      net^.setfieldsignal(net^.hiddenfield,sigmoid);
  685.      exit;
  686. {$endif}
  687.      dlg := nil;
  688.                  {init dialog and controls}
  689.      new(dlg,init(@self,'transferdlg'));
  690.      if dlg=nil then exit;
  691.      new(button,initresource(dlg,id_hiddentanh));
  692.      new(button,initresource(dlg,id_hiddensigmoid));
  693.      new(button,initresource(dlg,id_hiddenlinear));
  694.      new(button,initresource(dlg,id_outputtanh));
  695.      new(button,initresource(dlg,id_outputsigmoid));
  696.      new(button,initresource(dlg,id_outputlinear));
  697.      dlg^.transferbuffer := @funcbuffer;
  698.  
  699.      dlgok := application^.execdialog(dlg);
  700.      if dlgok <=0 then
  701.         begin
  702.         say('Could not open dialog');
  703.         exit;
  704.         end;
  705.  
  706.      if dlgok = idok then settransferfunctions;
  707.  
  708. {$IFDEF DEBUG}
  709.      printneuralerror;
  710.      writeln('Dialog returned ',dlgok);
  711. {$ENDIF}
  712.  
  713. end;
  714.  
  715.  
  716.  
  717. {--------------------------}
  718. procedure nnwindow.CMtrainparams(var mess: tmessage);
  719. {--------------------------}
  720. var
  721.    edit1, edit2, edit3, edit4 : pfloatedit; {numeric edit boxes}
  722.    edit5                      : pnumedit;
  723.    dlg                        : pspecdialog;
  724.    result,discard             : integer;
  725.  
  726. begin
  727.       new(dlg,init(@self,'trainparam'));   {init the dialog }
  728.       dlg^.transferbuffer := @learnbuffer;
  729.                                          {and the controls}
  730.       new(edit1,initresource(dlg,ed_userlearn,10,0,100));
  731.       new(edit2,initresource(dlg,ed_usermomen,10,0,100));
  732.       new(edit3,initresource(dlg,ed_userepoch,10,0,100));
  733.       new(edit4,initresource(dlg,ed_usermaxerr,10,0,10));
  734.       new(edit5,initresource(dlg,ed_usermaxiter,6,0,100000));
  735.  
  736.                                               {execute the dialog}
  737.       result := application^.execdialog(dlg);
  738.       if result <= 0 then
  739.          begin
  740.          say('Insufficient memory');
  741.          exit;
  742.          end;
  743. {      else dispose(dlg,done);}
  744.  
  745.       if (net <> nil) and (result=id_ok) then
  746.          begin
  747.          with learnbuffer do
  748.             begin
  749.             net^.learn := learnbuffer.lcoeff;    { tell the net}
  750.             net^.momen := learnbuffer.momentum;
  751.             showtrainparams;                     {tell the user}
  752.             end;
  753.           end;
  754. end;
  755.  
  756. {--------------------------}
  757. procedure nnwindow.showtrainparams;
  758. {--------------------------}
  759.                             { Redisplays current learning params }
  760. var
  761.    str1  : array[0..6] of char;
  762. begin
  763.      str1[1] := #0;
  764.      if netok then
  765.          begin
  766.          str(net^.learn:8:3,str1);
  767.          setdlgitemtext(hwindow,ed_userlearn,str1);
  768.          setdlgitemtext(hwindow,ed_infolearn,str1);
  769.  
  770.          str(net^.momen:8:3,str1);
  771.          setdlgitemtext(hwindow,ed_usermomen,str1);
  772.          setdlgitemtext(hwindow,ed_infomomen,str1);
  773.  
  774.          strcopy(str1,'None');
  775.          setdlgitemtext(hwindow,ed_userepoch,str1);
  776.  
  777.          str(learnbuffer.maxerr:8:3,str1);
  778.          setdlgitemtext(hwindow,ed_usermaxerr,str1);
  779.  
  780.          setdlgitemint(hwindow,ed_usermaxiter,learnbuffer.maxiter,false);
  781.          end;
  782. end;
  783.  
  784. {--------------------------}
  785. procedure nnwindow.shownetparams;
  786. {--------------------------}
  787. begin
  788.      if net <> nil then
  789.          begin
  790.          setdlgitemint(hwindow,id_incount,net^.inputfield^.count,false);
  791.          setdlgitemint(hwindow,id_hiddencount,net^.hiddenfield^.count,false);
  792.          setdlgitemint(hwindow,id_outcount,net^.outputfield^.count,false);
  793.          end;
  794. end;
  795.  
  796. {--------------------------}
  797. procedure nnwindow.CMtrain(var mess: tmessage);
  798. {--------------------------}
  799. begin
  800.      if ((dataok) and     { If all is set up...}
  801.         (logok) and
  802.         (net <> nil) and
  803.         not training )
  804.      then
  805.        begin
  806.        training := true;             {then open the files..}
  807.  
  808.        stopped:= false;
  809.        if not datainopen then opentextfile(strpas(datainname),datainfile);
  810.                                      {check for append on logfile}
  811.  
  812.        if not logopen then
  813.           if not logappend then
  814.              createtextfile(strpas(logname),logfile)
  815.           else
  816.              appendtextfile(strpas(logname),logfile);
  817.  
  818.                                      {do some interface stuff}
  819.        logopen     := true;
  820.        datainopen  := true;
  821.        showwindow(getdlgitem(hwindow,id_readnet), sw_hide);
  822.        showwindow(getdlgitem(hwindow,id_dataopen), sw_hide);
  823.        showwindow(getdlgitem(hwindow,id_dataclose), sw_hide);
  824.        showwindow(getdlgitem(hwindow,id_logopen), sw_hide);
  825.        showwindow(getdlgitem(hwindow,id_logclose), sw_hide);
  826.        enablewindow(getdlgitem(hwindow,id_cancel),false);
  827.        enablemenuitem(getmenu(hwindow),cm_exit,mf_bycommand or mf_grayed);
  828.        enablemenuitem(getmenu(hwindow),cm_fileopen,mf_bycommand or mf_grayed);
  829.        enablemenuitem(getmenu(hwindow),cm_filenew,mf_bycommand or mf_grayed);
  830.        enablemenuitem(getmenu(hwindow),cm_netedit,mf_bycommand or mf_grayed);
  831.        drawmenubar(hwindow);
  832.        report('Training');
  833.  
  834.        trainsession;                  {and train}
  835.  
  836.        spacedline(logfile,'Final Weights');
  837.        printmattofile(logfile,net^.weights^);
  838.        spacedline(logfile,' ');
  839.        reset(datainfile);
  840.  
  841.        training:= false;
  842.        showwindow(getdlgitem(hwindow,id_readnet), sw_show);
  843.        showwindow(getdlgitem(hwindow,id_dataopen), sw_show);
  844.        showwindow(getdlgitem(hwindow,id_dataclose), sw_show);
  845.        showwindow(getdlgitem(hwindow,id_logopen), sw_show);
  846.        showwindow(getdlgitem(hwindow,id_logclose), sw_show);
  847.        enablewindow(getdlgitem(hwindow,id_cancel),true);
  848.        enablemenuitem(getmenu(hwindow),cm_exit,mf_enabled or mf_bycommand);
  849.        enablemenuitem(getmenu(hwindow),cm_filenew,mf_bycommand or mf_enabled);
  850.        enablemenuitem(getmenu(hwindow),cm_fileopen,mf_bycommand or mf_enabled);
  851.        enablemenuitem(getmenu(hwindow),cm_netedit,mf_bycommand or mf_enabled);
  852.        drawmenubar(hwindow);
  853.        end
  854.      else
  855.        begin
  856.        messagebeep(mb_iconexclamation);
  857.        report('Setup not complete !');
  858.        end;
  859.  
  860. end;
  861.  
  862. {--------------------------}
  863. procedure nnwindow.trainsession;
  864. {--------------------------}
  865. label quickstop;
  866. var
  867.    i,j                  : word;
  868.    count                : longint;
  869.    lines,linelength     : integer;
  870.    totalerror,lasterror : double;
  871.    Traindata            : Trainsteprec;
  872.    incount,outcount     : integer;
  873.    mess                 : tmsg;
  874.    dvin                 : pdynavec; { for net response after training}
  875.  
  876. begin
  877.      if net = nil then
  878.         BEGIN
  879.         messagebeep(mb_iconexclamation);
  880.         messagebox(hwindow,'','No Network defined !',mb_ok);
  881.         exit;
  882.         END
  883.      else
  884.         modified := true;
  885.  
  886.                                 { Check out datafile }
  887.      readln(datainfile); readln(datainfile);
  888.      lines := countlines(datainfile);
  889.      readln(datainfile);readln(datainfile); {position correctly...}
  890.                                             {Data interpretation determined
  891.                                              by network structure}
  892.      outcount := net^.outputfield^.count;   
  893.      incount  := net^.inputfield^.count;
  894.      linelength:= incount + outcount;
  895.  
  896.                                 { Make datastructures}
  897.      with traindata do
  898.           begin
  899.           new(DMInput,init(lines,linelength));
  900.           new(DMdesired,init(lines,outcount));
  901.           new(DVerror,init(outcount,1));
  902.  
  903.                                 { Get input data}
  904.  
  905.           if linestomat(datainfile,DMinput^) <> 0 then
  906.          begin
  907.              dispose(DMInput,done);
  908.              dispose(DMdesired,done);
  909.              dispose(DVerror,done);
  910.              say('Error reading datafile !');
  911.              exit;
  912.          end;;
  913.           writeln(logfile,'IO MATRIX');
  914.           printmattofile(logfile,DMinput^);
  915.           for i := 1 to lines do
  916.               for j := 1 to outcount do
  917.                  DMdesired^.put(i,j,DMinput^.get(i,incount+j));
  918.           writeln(logfile,'DESIRED MATRIX');
  919.           printmattofile(logfile,DMdesired^);
  920.  
  921.           for i := 1 to outcount do DMinput^.deletecol(incount+1);
  922.           writeln(logfile,'INPUT MATRIX');
  923.           printmattofile(logfile,DMinput^);
  924.           end;
  925.  
  926.      setupnetparams;
  927.      showtrainparams;
  928.                     { Start the training...}
  929.  
  930.      count      := 0;
  931.      totalerror :=9999;
  932.      repeat
  933.          yield(mess);
  934.          edinfocount^.transfer(@count,tf_setdata);
  935.          edinfoerror^.transfer(@totalerror,tf_setdata);
  936.  
  937.             count := count +1;
  938.             totalerror := TrainEpoch(traindata,lines); {present all data once}
  939.             edinfocount^.transfer(@count,tf_setdata);
  940.             edinfoerror^.transfer(@totalerror,tf_setdata);
  941.             if (count mod 5)=0 then
  942.                 writeln(logfile,'Event # ',count,totalerror:12:6);
  943.  
  944.          if stopped then
  945.             begin
  946.             report('Stopped');
  947.             totalerror := 0;
  948.             spacedline(logfile,' ---- Unexpected Training stop ! -----');
  949.             end;
  950.      until (totalerror < learnbuffer.maxerr) or
  951.           (count > learnbuffer.maxiter);
  952.  
  953.                               {finished Training...}
  954.  
  955.      if not stopped then report('Trained !') else report('Unexpected stop');
  956.      with traindata do
  957.        begin
  958.        spacedline(logfile,'Network response: ');
  959.        for j := 1 to lines do
  960.           begin
  961.           dminput^.getrow(j,dvin);
  962.           net^.feedforward(dvin);
  963.           write(logfile,' inputvec  :');
  964.           printvectofile(logfile,80,dvin^);
  965.           write(logfile,' response : ');
  966.           for i := 1 to net^.outputfield^.count do
  967.              write(logfile,pneuron(net^.outputfield^.at(i-1))^.output:8:3);
  968.           writeln(logfile);
  969.           end;
  970.        flush(logfile);
  971.  
  972. quickstop:
  973.        dispose(dmdesired,done);
  974.        dispose(dminput,done);
  975.        dispose(dverror,done);
  976.        end;
  977.  
  978. end;
  979.  
  980.  
  981. {----------------------------}
  982.  function nnwindow.trainepoch(var data : trainsteprec; count: word) : double;
  983. {----------------------------}
  984. var                           { Presents count I/O pairs once}
  985.    lasterror, totalerror    : double;
  986.    dvin,dvdesired           : pdynavec;
  987.    thisone                  : pneuron;
  988.    i,j                        : integer;
  989.    mess                       : tmsg;
  990. begin
  991.        for j := 1 to count do { For each training datum...}
  992.  
  993.           begin
  994.           inc(count);
  995.           data.DMdesired^.getrow(j,dvdesired); {get data}
  996.           data.DMinput^.getrow(j,dvin);
  997.           net^.feedforward(dvin);              { Feed it forward}
  998.            
  999.                                 {make error vector}
  1000.           for i := 1 to net^.outputfield^.count do  {...for each output neuron}
  1001.               begin
  1002.               yield(mess);
  1003.               thisone := net^.outputfield^.at(i-1);
  1004.               lasterror := (dvdesired^.get(i) - thisone^.output);
  1005.               totalerror := totalerror + abs(lasterror);
  1006.               data.dverror^.put(i, lasterror);
  1007.               end;              { feed error back}
  1008.  
  1009.           net^.train(data.dverror);
  1010.           end;
  1011.  
  1012.        trainepoch := totalerror;
  1013.  
  1014. end;
  1015.  
  1016.  
  1017. {----------------------------}
  1018. procedure nnwindow.setupnetparams;
  1019. {----------------------------}
  1020.                               { Get data from buffers to the existing net}
  1021. begin
  1022.      if net <> nil then
  1023.  
  1024.      begin                           { Setup Backpropnet}
  1025.      net^.learn := learnbuffer.lcoeff;
  1026.      net^.momen := learnbuffer.momentum;
  1027.      end;
  1028. end;
  1029.  
  1030.  
  1031. {--------------------------}
  1032. procedure nnwindow.CMrun(var mess : tmessage);
  1033. {--------------------------}
  1034. var
  1035.    DMInput      : pdynamat;
  1036.    DVIn         : pdynavec;
  1037.    lines,i,j     : integer;
  1038. begin
  1039.    if (net <> nil) and (dataok) and (logok) then
  1040.    begin
  1041.      if not datainopen then
  1042.        if opentextfile(strpas(datainname),datainfile) <> 0 then exit;
  1043.  
  1044. {     if not logopen then
  1045.        if createtextfile(strpas(logname),logfile) <> 0 then exit;}
  1046.        if not logopen then
  1047.           if not logappend then
  1048.              begin
  1049.              if createtextfile(strpas(logname),logfile)<>0 then exit;
  1050.              end
  1051.           else
  1052.              if appendtextfile(strpas(logname),logfile)<>0 then exit;
  1053.  
  1054.      logopen     := true;
  1055.      datainopen  := true;
  1056.  
  1057.      reset(datainfile);
  1058.      readln(datainfile); readln(datainfile);
  1059.      lines := countlines(datainfile);
  1060.      readln(datainfile);readln(datainfile); {position correctly...}
  1061.      new(dminput,init(lines,net^.inputfield^.count));
  1062.  
  1063.      spacedline(logfile,'  ------ Run Start ------');
  1064.                                 { Get input data}
  1065.      linestomat(datainfile,DMinput^);
  1066.      writeln(logfile,'DATA MATRIX');
  1067.           printmattofile(logfile,DMinput^);
  1068.      spacedline(logfile,'Network response');
  1069.        for j := 1 to lines do
  1070.           begin
  1071.           dminput^.getrow(j,dvin);
  1072.           net^.feedforward(dvin);
  1073.           setdlgitemint(hwindow,ed_infocount,j,false);
  1074.           printvectofile(logfile,80,dvin^);
  1075.           for i := 1 to net^.outputfield^.count do
  1076.              write(logfile,pneuron(net^.outputfield^.at(i-1))^.output:8:3);
  1077.           writeln(logfile);
  1078.           end;
  1079.        flush(logfile);
  1080.        reset(datainfile);
  1081.  
  1082.        dispose(dminput,done);
  1083.        report('Run Complete');
  1084.        spacedline(logfile,'Run Complete');
  1085.      end
  1086.    else
  1087.        begin
  1088.        messagebeep(mb_iconexclamation);
  1089.        report('Setup not complete !');
  1090.        end;
  1091. end;
  1092. {--------------------------}
  1093. procedure nnwindow.CMdisplay(var mess : tmessage);
  1094. {--------------------------}
  1095. begin
  1096.      messagebox(hwindow,'Not implemented','Bad Luck',mb_OK);
  1097. end;
  1098.  
  1099. {----------------------------}
  1100. procedure nnwindow.BNResetweights(var mess : tmessage);
  1101. {----------------------------}
  1102.  
  1103. begin
  1104.   if (net <> nil) then
  1105.         begin
  1106.         net^.randomweights(0.5);
  1107.         net^.setconnections;
  1108.         report('Weights Reset to near zero');
  1109.         if logopen then spacedline(logfile,'----- Reset ------');
  1110.         end
  1111. end;
  1112.  
  1113. {----------------------------}
  1114. procedure nnwindow.BNstopnet(var mess : tmessage);
  1115. {----------------------------}
  1116.                               { Flags the running net to stop }
  1117. begin
  1118.      if running or training then
  1119.         begin
  1120.         running   := false;
  1121.         training  := false;
  1122.         stopped   := true;
  1123.         end
  1124. end;
  1125.  
  1126. {----------------------------}
  1127. procedure nnwindow.BNsavenet(var mess : tmessage);
  1128. {----------------------------}
  1129. begin
  1130.      CMsavefile(mess);
  1131. end;
  1132.  
  1133. {----------------------------}
  1134. procedure nnwindow.BNreadnet(var mess : tmessage);
  1135. {----------------------------}
  1136. begin
  1137.  
  1138.      CMopenfile(mess);
  1139. end;
  1140.  
  1141. {----------------------------}
  1142. procedure nnwindow.BNshakenet(var mess : tmessage);
  1143. {----------------------------}
  1144. begin
  1145.      if (net <> nil) then net^.shake(1.5);
  1146. end;
  1147.  
  1148. {----------------------------}
  1149. procedure nnwindow.BNtrain(var mess : tmessage);
  1150. {----------------------------}
  1151. begin
  1152.      CMTrain(mess);
  1153. end;
  1154.  
  1155.  
  1156. {----------------------------}
  1157. procedure nnwindow.BNSettransfer(var mess : tmessage);
  1158. {----------------------------}
  1159. begin
  1160.     CMSetTransfer(mess);
  1161. end;
  1162.  
  1163. {----------------------------}
  1164. procedure nnwindow.showicon(state : word);
  1165. {----------------------------}
  1166.                              {Indicates the presence of a valid net}
  1167. begin
  1168.      if (state=sw_hide) or (state=sw_show) then
  1169.         showwindow(getdlgitem(hwindow,id_icon),state)
  1170. end;
  1171.  
  1172. {----------------------------}
  1173. procedure nnwindow.report(rep:pchar);
  1174. {----------------------------}
  1175. begin
  1176.      setdlgitemtext(hwindow,id_status,rep);
  1177. end;
  1178.  
  1179. {----------------------------}
  1180. procedure nnwindow.BNdataopen(var mess : tmessage);
  1181. {----------------------------}
  1182. begin
  1183.      cmdatain(mess);
  1184. end;
  1185.  
  1186. {----------------------------}
  1187. procedure nnwindow.BNdataclose(var mess : tmessage);
  1188. {----------------------------}
  1189. begin
  1190.      closedatafile;
  1191. end;
  1192.  
  1193.  
  1194. {----------------------------}
  1195. procedure nnwindow.BNlogopen(var mess : tmessage);
  1196. {----------------------------}
  1197. begin
  1198.      cmdataout(mess);
  1199. end;
  1200.  
  1201.  
  1202. {----------------------------}
  1203. procedure nnwindow.BNlogclose(var mess : tmessage);
  1204. {----------------------------}
  1205. begin
  1206.      closelogfile;
  1207. end;
  1208.  
  1209. {----------------------------}
  1210. procedure nnwindow.BNtrainparams(var mess : tmessage);
  1211. {----------------------------}
  1212. begin
  1213.      CMtrainparams(mess);
  1214. end;
  1215. {----------------------------}
  1216. procedure nnwindow.EditFile(pathname : pchar);
  1217. {----------------------------}
  1218. var
  1219.    cmdline  : array[0..80] of char;
  1220.  
  1221. begin                        {make the filename...}
  1222.  
  1223.         strpcopy(cmdline,'Notepad.exe ');
  1224.         strlcat(cmdline,pathname,60);
  1225.         if winexec(cmdline,sw_show) < 32
  1226.       then say('Could not find Notepad');
  1227. end;
  1228.  
  1229. {----------------------------}
  1230. procedure nnwindow.BNdataedit(var mess : tmessage);
  1231. {----------------------------}
  1232. begin
  1233.      if not dataok then exit else editfile(datainname);
  1234. end;
  1235.  
  1236. {----------------------------}
  1237. procedure nnwindow.BNLogedit(var mess : tmessage);
  1238. {----------------------------}
  1239. begin
  1240.      if running or training then exit;
  1241.      if logok then editfile(logname)
  1242.      else
  1243.         if lastlog <> '' then editfile(lastlog);
  1244. end;
  1245.  
  1246.  
  1247. {----------------------------}
  1248. procedure nnwindow.CMAbout(var mess : tmessage);
  1249. {----------------------------}
  1250. var
  1251.    dlg  : pdialog;
  1252. begin
  1253.      new(dlg,init(@self,'aboutdlg'));
  1254.      application^.execdialog(dlg);
  1255. end;
  1256.  
  1257. {----------------------------}
  1258. procedure nnwindow.CHrandom(var mess : tmessage);
  1259. {----------------------------}
  1260. begin
  1261.      if chrandomdata^.getcheck = bf_checked
  1262.          then randomdata := true else randomdata := false;
  1263. end;
  1264.  
  1265.  
  1266. {----------------------------}
  1267. procedure nnwindow.CMSlughelp(var mess : tmessage);
  1268. {----------------------------}
  1269. begin
  1270.      winhelp(hwindow,'slughlp3.hlp',help_contents,0);
  1271. end;
  1272.  
  1273.    {---------------------- SPECDIALOG PROCEDURES ------------------------}
  1274.  
  1275. {----------------------------}
  1276. procedure specdialog.zerocounts(var mess : tmessage);
  1277. {----------------------------}
  1278. var
  1279.    zero : pchar;
  1280. begin
  1281.     zero       := '0';
  1282.     senddlgitemmsg(id_netspecin, wm_settext,0,longint(zero) );
  1283.     senddlgitemmsg(id_netspecout, wm_settext,0,longint(zero) );
  1284.     senddlgitemmsg(id_netspechidden, wm_settext,0,longint(zero) );
  1285. end;
  1286.  
  1287.  
  1288.  
  1289.  
  1290.  
  1291.    {---------------------- APPLICATION PROCEDURES -----------------------}
  1292.  
  1293. {----------------------------}
  1294. procedure ANNpgm.initmainwindow;
  1295. {----------------------------}
  1296. begin
  1297.      mainwindow := new(pNNwindow,init(nil,'ALLIN'));
  1298. end;
  1299.  
  1300.  
  1301.  
  1302. {======================================== MAIN ====================================================}
  1303. var
  1304.    demo         : ANNpgm;
  1305.    space        : longint;
  1306.    temp         : array[0..20] of char;
  1307. begin
  1308.      demo.init('ANN Program 2');
  1309.      demo.run;
  1310.      demo.done;
  1311.  
  1312. end.
  1313.  
  1314. {---------------------------------------  END  -----------------------------------------------------}
  1315.